By scenario

Breaking things down by scenario, we see that we get the biggest difference in the ZOO case. This makes sense because only this scenario has a large number of extreme negative outcomes. However, even here, high-control participants still think of negative outcomes.

check_plot + facet_wrap(~scenario)  # plot

Why do people think of negative outcomes when they are impossible to occur? This could be due to a weak manipulation. However, it could also be that people have a default sampling policy that is sensitive to both signed and absolute value (as would be adaptive in cases of moderate control) and they have only a limited ability to modulate that policy based on contextual factors. The latter hypothesis is consistent with Fiery’s previous work. Implications for the model are discussed below.

👉 see Alternative basic predictions for analyses that treat consideration as the IV (as I originally proposed).

👉 see Z-scoring for these analyses with evaluations z-scored within participant. (This one is particulary worth checking out).

👉 There is mixed evidence for learning, documented in Order effects.

Individual differences

We hope that most people have similar outcome value distributions for each problem. First, we can look at the raw distributions for the first 12 participants.

pid = "VACATION"
for (pid in unique(df$scenario)) {
    df %>% 
        # filter(outcome != "UNK") %>% 
        filter(subj <= 12 & scenario == pid) %>% 
        ggplot(aes(as_factor(evaluation))) +
            geom_bar() +
            facet_wrap(~ subj) +
            theme(axis.text.x = element_blank(), axis.ticks.x = element_blank()) +
            ggtitle(pid)
    fig(pid, 7.5, 5)
}

df %>% 
    # filter(outcome != "UNK") %>% 
    group_by(scenario, wid) %>% 
    summarise(across(evaluation, list(μ=mean, σ=sd, skew=skewness), .names="{fn}"))  %>% 
    pivot_longer(μ:skew, names_to="moment", values_to="value") %>% 
    mutate(moment = recode_factor(moment, "μ" = "mean", "σ" = "sd")) %>% 
    ggplot(aes(scenario, value)) + 
        # geom_violin() +
        geom_quasirandom(size=.8) +
        stat_summary(fun.data=mean_cl_boot, color="red") +
        facet_wrap(~moment, scales="free") +
        scale_x_discrete(label=abbreviate, name=NULL)

df %>% 
    # filter(outcome != "UNK") %>% 
    group_by(scenario, wid) %>% 
    summarise(across(evaluation, list(μ=mean, σ=sd, skew=skewness), .names="{fn}"))  %>% 
    pivot_longer(μ:skew, names_to="moment", values_to="value") %>% 
    mutate(moment = recode_factor(moment, "μ" = "mean", "σ" = "sd")) %>% 
    ggplot(aes(scenario, value)) + 
        # geom_violin() +
        geom_hline(yintercept=0, size=0.5, linetype="dashed") +
        geom_line(aes(group=wid), alpha=0.5, size=0.5) +
        stat_summary(fun.data=mean_cl_boot, color="red") +
        facet_wrap(~moment, scales="free") +
        scale_x_discrete(label=abbreviate, name=NULL)

Higher outcome evaluations in high-control

Perhaps the most obvious and basic prediction one could make is that the scenarios should be rated more highly in the high control condition.

scenarios %>% 
    ggplot(aes(scenario, scenario_evaluation, color=control)) +
    stat_summary(fun.data=mean_cl_boot, position=position_dodge(width=.8)) +
    geom_quasirandom(size=.8, dodge.width=.8, alpha=0.5) + control_colors

scenarios %>% lmer(scenario_evaluation ~ control * scenario + (1|wid), data=.) %>% plot_coefs(colors="black")

Sort of? The fact that we actually see higher ratings for low-control in VACATION is puzzling. It might be that participants in the low-control condition just happen to have higher individual offsets (i.e., they would be higher in all the scenarios if there wasn’t a manipulation).

Outcome evaluations predict scenario evaluations

Evaluations of the full scenario should depend on evaluations of individual outcomes of that scenario.

X = df %>% 
    group_by(control, wid, scenario) %>% 
    summarise(outcome_evaluation = mean(evaluation)) %>% 
    left_join(select(scenarios, control, wid, scenario, scenario_evaluation))

X %>% ggplot(aes(outcome_evaluation, scenario_evaluation)) +
    stat_summary_bin(fun.data=mean_cl_boot, bins=5, position=position_dodge(width=1), alpha=0.3) +
    geom_smooth(method="lm")

🎊 woop dee doo 🎊

What we really want to see is that the outcome evaluations predict scenario evaluations over and above the scenario and participant offsets. That is, the outcome evaluations should provide some signal about the interaction between participant and scenario.

To test this, we’ll use within-participant z-scored evaluations (both outcome and scenario) and we’ll separate by scenario. Note that the _z suffix will always indicate within-participant z-scoring. See Z-scoring for more information.

X = df %>% 
    group_by(wid, scenario, considered) %>% 
    summarise(outcome_evaluation_z = mean(evaluation_z)) %>% 
    left_join(select(scenarios, wid, scenario, scenario_evaluation_z)) 

X %>% ggplot(aes(outcome_evaluation_z, scenario_evaluation_z)) +
    stat_summary_bin(fun.data=mean_cl_boot, bins=5, position=position_dodge(width=1), alpha=0.7) +
    geom_smooth(method="lm", alpha=0.2) +
    facet_wrap(~scenario)

    # facet_wrap(~control, labeller=label_glue("{control} control")) + 

X %>% lm(scenario_evaluation_z ~ 0 + outcome_evaluation_z + scenario, data=.) %>% summ

OK that’s good…

Are considered outcomes more important?

…but what we’d really like to see is that the evaluations are specifically sensitive to the considered outcomes (vs. the unconsidered outcomes). Unfortunately, this does not seem to be the case.

X = df %>% 
    mutate(considered=if_else(considered, "considered", "unconsidered")) %>% 
    group_by(wid, scenario, considered) %>% 
    summarise(outcome_evaluation_z = mean(evaluation_z)) %>% 
    left_join(select(scenarios, wid, scenario, scenario_evaluation_z)) 

X %>% ggplot(aes(outcome_evaluation_z, scenario_evaluation_z, color=considered, fill=considered)) +
    stat_summary_bin(fun.data=mean_cl_boot, bins=5, position=position_dodge(width=1), alpha=0.3) +
    geom_smooth(method="lm", alpha=0.1) +
    facet_wrap(~scenario) + 
    theme(legend.position="top") +
    considered_colors

X1 = df %>% 
    group_by(wid, scenario, considered) %>% 
    summarise(y = mean(evaluation_z)) %>% 
    mutate(x=if_else(considered, "considered_val", "unconsidered_val")) %>% 
    select(-considered) %>% 
    ungroup() %>% 
    pivot_wider(names_from=x, values_from=y, names_repair="unique") %>% 
    right_join(scenarios)

X1 %>% lm(scenario_evaluation_z ~ considered_val + unconsidered_val + scenario, data=.) %>% summ

Ouch. It looks like the considered values are selectively not contributing to the overall scenario evaluation. And yes I did check my response coding. 😉

But before we throw up our hands in despair, it’s important to note that there are many more unconsidered outcomes than considered outcomes, and so the mean of the latter is a much noisier measure. If we just look at the relationship between individual outcome evaluations and the total scenario evaluation, we do see that the considered outcomes have a slightly stronger relationship.

df %>% 
    inner_join(select(scenarios, -considered)) %>% 
    group_by(considered) %>% 
    nest() %>%
    mutate(result = map(data, function(.) {
        m = lm(scenario_evaluation_z ~ evaluation_z + scenario, data=.)
        tibble(
            slope = m$coef["evaluation_z"],
            cor = with(., cor(evaluation_z, scenario_evaluation_z, use='complete'))
        )
    })) %>% 
    unnest(result) %>%
    select(-data) %>% kable

To be honest, I don’t fully understand how the slope can be steeper in this regression but less steep in the plots. I think it must be because in the plotted regressions, we have one observations per trial, whereas in the table regression, we have one observation per outcome. I’m not sure which is a better test; or perhaps there is a third way.

Even if we trust the second (more positive) set of results, the conclusion is not especially optimistic. It seems pretty likely that either (1) the scenario evaluations are really based on a gist-like perception of the situation rather than aggregations of separate outcome samples, and/or (2) the outcomes participants report having considered are not a veridicial measure of what they actually thought about.

Number of options considered

This is pretty self-explanatory. Overall, it seems like we are getting pretty decent rates.

scenarios %>% 
    ggplot(aes(n_considered, y=..prop..)) + geom_bar()

scenarios %>% 
    group_by(wid) %>% 
    mutate(nc = mean(n_considered)) %>% 
    ungroup() %>% 
    mutate(wid = fct_reorder(wid, desc(nc))) %>% 
    ggplot(aes(wid, n_considered)) + 
        stat_summary(geom="line", group=0, color="red", alpha=0.5) +
        geom_point(alpha=0.5) + 
        xlab("participant") +
        scale_y_continuous(breaks= breaks_pretty(6)) +
        theme(axis.text.x = element_blank())

scenarios %>% 
    plot_line_range(trial_number, n_considered) + 
    geom_quasirandom(size=1) +
    scale_y_continuous(breaks= breaks_pretty(6)) +
    scale_x_continuous(breaks= breaks_pretty(3))

Implications for the model

The model being fit to the first set of plots is very similar to our initial “apples/oranges” mixture model. The fits are pretty darn good, suggesting that a model like the initially proposed model will be able to fit the data well.

In contrast, if we look at the predictions from the analytic maximum of Gaussians model, we see that for even moderate \(k\), the probability of sampling extreme low-value outcomes is very small. Of course, these outcome distributions are highly non-Gaussian; accounting for that in the model could change things. Specifically, we can construct a sampling distribution based on the empirical CDF of values in the scenario or perhaps a parametric approximation such as the skew Normal. Two challenges with this approach:

• It’s not clear how to account for the value distribution without making unrealistic assumptions about people’s pre-sampling knowledge of that distribution. This would be like the issue with presupposing the mean for UWS, but also for higher moments.
• The model will have less flexibility in how it can capture partial adaptation. We have the \(k\) parameter of course, but these results suggest that people are asymetric in their ability to increase positive outcome sampling vs. reduce negative outcome sampling (in particular, see the ZOO panel in By scenario). I think this will be difficult to capture in any model that composes UWS with value-weighted sampling as opposed to having two separate and independently controllable mechansisms.

Here’s another approach, using the apples/oranges mixture model as a base:

For each scenario:

1. Identify optimal weights on signed vs absolute value.
2. Estimate best-fitting weights from human data.
3. Compare, drawing inferences about people’s sensitivity to various components of the distribution and ability to modulate different aspects of their sampling poloicy.

Based on these results, we will hopefully be able to specify structured models of the contextual adaptation, allowing us to e.g. predict peoples sampling policies based on properties of distribution rather than fitting the weights for each scenario.

I still think the analytic approach is theoretically more interesting and the challenges are not necessarily insurmountale. The results with Z-scored evaluations also seem to be more consistent with that model. However, the path forward with the apples/oranges model is still more clear to me.

Implications for the paradigm

Order effects

Do participants get better at sampling in a manner consistent with their condition over time?

df %>% 
    # filter(scenario!="FRUIT") %>% 
    left_join(select(scenarios, wid, scenario, trial_number)) %>% 
    mutate(last_trial = as.numeric(trial_number==3)) %>% 
    ggplot(aes(evaluation, as.numeric(considered), color=control)) +
    stat_summary_bin(fun.data=mean_cl_boot, bins=5, alpha=0.3, 
                     position=position_dodge(width=.5)) +
    geom_smooth(se=F, size=0.8, linetype = "dotted", alpha=0.3) +
    # geom_smooth(se=F, method=lm, formula=y ~ x + abs(x), alpha=0.1) +
    geom_smooth(se=F, method=glm, 
        formula=y ~ x + abs(x - 0),
        method.args = list(family = "binomial"),
        alpha=0.1) +
    ylab("consideration probability") +
    facet_grid(scenario ~ trial_number,  labeller = label_glue(
        cols = "trial {trial_number}",
        rows = "{scenario}"
    )) +
    control_colors

Note that all participants saw FRUIT first. For ZOO, it does look like high-control participants do a better job of ignoring low-value outcomes. However, VACATION gets a little worse. Given that there are two sets of participants here (one that sees VACATION first and one that sees ZOO first), it seems likely to me that this is a coincidental alignment of individual differences with order. But…

consideration_model_time = df %>% 
    left_join(select(scenarios, wid, scenario, trial_number)) %>% 
    # mutate(trial = trial_number - 1)
    # filter(scenario!="FRUIT") %>% 
    # mutate(last_trial = as.numeric(trial_number==3)) %>% 
    glm(considered ~ trial_number * control * (zscore(evaluation) + zscore(abs(evaluation))), family=binomial, data=.)

summ(consideration_model_time)

We do see a significant third-order interaction, such that high-control participants attend to high- value outcomes more on later trials (second to last row). The more model taking into account order has a better AIC: 2131 vs 2143.

Alternative basic predictions

In this set of analyses, we treat consideration as an IV and ask how signed/absoluate evaluations differ among considered vs. unconsidered outcomes. I think these are superseded by the analyses in [Basic predictions] but I’m putting them here for completeness.

plot_line_range(df, considered, evaluation, control) + control_colors

df %>% 
    mutate(considered = as.numeric(considered)) %>% 
    lmer(evaluation ~ considered * control + (1|wid), data=.) %>% plot_coefs(colors="black")

plot_line_range(df, considered, abs(evaluation), control) + control_colors

df %>% 
    mutate(considered = as.numeric(considered)) %>% 
    lmer(abs(evaluation) ~ considered * control + (1|wid), data=.) %>% plot_coefs(colors="black")

plot_line_range(df, considered, evaluation, control) + facet_wrap(~ scenario) + control_colors

plot_line_range(df, considered, abs(evaluation), control) + facet_wrap(~ scenario) + control_colors

X = df %>% 
    group_by(control, wid, scenario, considered) %>%
    summarise(eval_sd = sd(evaluation)) 

X %>% plot_line_range(considered, eval_sd, control) + control_colors

X %>% lm(eval_sd ~ considered * control, data=.) %>% plot_coefs(colors="black")

X %>% plot_line_range(considered, eval_sd, control) + facet_wrap(~scenario) + control_colors

Z-scoring

Instead of using mixed effects, we can z-score the evaluations within participant. This better accounts for individual differences in using the scale but it also seems a little weird to do with a between-participant condition. That being said there’s no reason to think that control would affect evaluation of individual outcomes, so this is probably fine.

check_plot_z = df %>% 
    # filter(abs(evaluation_z) < 2) %>% 
    ggplot(aes(evaluation_z, as.numeric(considered), color=control)) +
    stat_summary_bin(fun.data=mean_cl_boot, bins=5, alpha=0.3, 
                     position=position_dodge(width=.5)) +
    geom_smooth(se=F, size=0.8, linetype = "dotted", alpha=0.2) +
    # geom_smooth(se=F, method=lm, formula=y ~ x + abs(x), alpha=0.1) +
    geom_smooth(se=F, method=glm, 
        formula=y ~ x + abs(x - 0),
        method.args = list(family = "binomial"),
        alpha=0.1) +
    ylab("consideration probability") +
    control_colors
check_plot_z

check_plot_z + facet_wrap(~scenario)  # plot

consideration_model_z = df %>% 
    glm(considered ~ control * (zscore(evaluation_z) + zscore(abs(evaluation_z))), family=binomial, data=.)

plot_coefs(consideration_model_z, omit.coefs=c("controlhigh", "(Intercept)"), colors="black")

plot_line_range(df, considered, evaluation_z, control) + control_colors

df %>% 
    mutate(considered = as.numeric(considered)) %>% 
    lm(evaluation_z ~ considered * control , data=.) %>% plot_coefs(colors="black")

plot_line_range(df, considered, abs(evaluation_z), control) + control_colors

df %>% 
    mutate(considered = as.numeric(considered)) %>% 
    lmer(abs(evaluation_z) ~ considered * control + (1|wid), data=.) %>% plot_coefs(colors="black")

Outcome-based analysis

In the previous analyses we have operationalized outcome value by the participants individual rating. We have effectively ignored the identity of outcome itself. What if we instead assume that people have consistent preferences and use the average evaluation across all participants. We use within-participant z-scored evaluations here.

We also exclude all outcomes not in our original set. These were fairly rare.

# unknown rate is low enought that we can ignore
df %>% 
    group_by(scenario, control) %>% 
    summarise(mean(outcome == "UNK")) %>% kable

(Side note: for all the previous analyses I’ve ignored the fact that the set of rated outcomes is not identical for all participants (because of these extra considered outcomes. I’m not sure if that was the right call.)

First let’s look at the outcome ratings themselves. The dark error bars show 95% CI and the lighter bars show the SD to illustrate variability.

df %>% 
    filter(outcome != "UNK") %>% 
    ggplot(aes(evaluation_z, fct_reorder(outcome, evaluation_z, mean))) +
        stat_summary(fun.data=mean_sdl, fun.args = list(mult = 1), color="gray") + 
        stat_summary(fun.data=mean_cl_boot) + 
        facet_wrap(~ scenario, ncol=1, scales="free_y") + 
        geom_vline(xintercept=0, linetype="dashed") +
        no_grid + ylab(NULL)

I am truly shocked that pineapple is rated so low…🍍😢

Distribution of considered outcomes, sorted by aggregate value looks reasonable, but I think plotting by non-aggregate evaluation is more informative.

agg_eval = df %>% 
    filter(outcome != "UNK") %>% 
    group_by(outcome) %>% 
    mutate(
        agg_evaluation = mean(evaluation_z),
        outcome = fct_reorder(outcome, agg_evaluation)
    )

agg_eval %>% 
    filter(considered) %>% 
    ggplot(aes(x=..count.., y=fct_reorder(outcome, agg_evaluation))) + 
    geom_bar(aes(fill=control),  alpha=0.3, position="identity") +
    facet_wrap(~ scenario, ncol=1, scales="free_y") + control_colors + no_grid

Redoing the main analysis with the aggregate evalutions, we get a much noisier pattern of results.

agg_eval %>% ggplot(aes(agg_evaluation, as.numeric(considered), color=control)) +
    stat_summary_bin(fun.data=mean_cl_boot, bins=5, alpha=0.3, 
                     position=position_dodge(width=.1)) +
    geom_smooth(se=F, size=0.8, linetype = "dotted", alpha=0.3) +
    # geom_smooth(se=F, method=lm, formula=y ~ x + abs(x), alpha=0.1) +
    geom_smooth(se=F, method=glm, 
        formula=y ~ x + abs(x - 0),
        method.args = list(family = "binomial"),
        alpha=0.1) +
    ylab("consideration probability") +
    control_colors

agg_consideration_model = agg_eval %>% 
    glm(considered ~ control * (zscore(agg_evaluation) + zscore(abs(agg_evaluation))), family=binomial, data=.)

m = agg_eval %>% 
    glm(considered ~ control * (zscore(evaluation) + zscore(abs(evaluation))), family=binomial, data=.)

summ(agg_consideration_model)

# plot_coefs(consideration_model2, omit.coefs=c("controlhigh", "(Intercept)"), colors="black")

The model that predicts consideration probability based on aggregate outcome evaluations has a worse AIC: 1939 vs 1879.

Free-response comprehension check

“In one brief sentence, explain how the fruit will be chosen”

full_pdf %>% select(control, comp_free) %>% arrange(control) %>% kable

True/false comprehension check

“True or false? You don’t have to eat any fruit if you don’t want to.” (correct: false)

table(full_pdf$obligatory_check) %>% kable(col.names=c("response type", '# participants'))